home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FORTRAN1.LZH / ASCII.FOR next >
Text File  |  1988-02-08  |  4KB  |  161 lines
  1.       SUBROUTINE ASCII ( STRING )
  2. C*
  3. C*                  *******************************
  4. C*                  *******************************
  5. C*                  **                           **
  6. C*                  **          ASCII            **
  7. C*                  **                           **
  8. C*                  *******************************
  9. C*                  *******************************
  10. C*
  11. C*     SUBPROGRAM :
  12. C*          ASCII
  13. C*
  14. C*     AUTHOR :
  15. C*          ART RAGOSTA
  16. C*          MS 207-5
  17. C*          AMES RESEARCH CENTER
  18. C*          MOFFETT FIELD, CALIF  94035
  19. C*          (415) 694-5578
  20. C*
  21. C*     PURPOSE :
  22. C*          TO REPLACE TEXT STRINGS OF THE TYPE CREATED BY SUBROUTINE
  23. C*          DASCII WITH ASCII CHARACTERS (SEE DASCII).
  24. C*
  25. C*     INPUT ARGUMENTS :
  26. C*          STRING - STRING TO BE ASCIIFIED.
  27. C*
  28. C*     OUTPUT ARGUMENTS :
  29. C*          STRING - ASCIIFIED STRING ( IN PLACE ).
  30. C*
  31. C*     INTERNAL WORK AREAS :
  32. C*          WORK  - TEMPORARY STORAGE FOR STRING WHILE IT IS BUILT.
  33. C*          TABLE - ASCII MNEMONIC STRINGS FOR CONTROL CHARACTERS.
  34. C*
  35. C*     COMMON BLOCKS :
  36. C*          NONE
  37. C*
  38. C*     FILE REFERENCES :
  39. C*          NONE
  40. C*
  41. C*     DATA BASE ACCESS :
  42. C*          NONE
  43. C*
  44. C*     SUBPROGRAM REFERENCES :
  45. C*          NONE
  46. C*
  47. C*     ERROR PROCESSING :
  48. C*          NONE
  49. C*
  50. C*     TRANSPORTABILITY LIMITATIONS :
  51. C*          NONE
  52. C*
  53. C*     ASSUMPTIONS AND RESTRICTIONS :
  54. C*          NONE
  55. C*
  56. C*     LANGUAGE AND COMPILER :
  57. C*          ANSI FORTRAN 77
  58. C*
  59. C*     VERSION AND DATE :
  60. C*          VERSION I.0     30-JAN-85
  61. C*
  62. C*     CHANGE HISTORY :
  63. C*          30-JAN-85    INITIAL VERSION
  64. C*
  65. C***********************************************************************
  66. C*
  67.       CHARACTER *255 WORK
  68.       CHARACTER *(*) STRING
  69.       CHARACTER *3 TABLE(0:32), THREE
  70.       DATA TABLE /'NUL',  'SOH',  'STX',  'ETX',  'EOT',  'ENQ',
  71.      $    'ACK',  'BEL',  ' BS',  ' HT',  ' LF',  ' VT',  ' FF',
  72.      $    ' CR',  ' SO',  ' SI',  'DLE',  'DC1',  'DC2',  'DC3',
  73.      $    'DC4',  'NAK',  'SYN',  'ETB',  'CAN',  ' EM',  'SUB',
  74.      $    'ESC',  ' FS',  ' GS',  ' RS',  ' US',  'DEL' /
  75. C
  76.       L = LEN ( STRING )
  77.       WORK = ' '
  78.       IW = 0
  79.       IS = 0
  80. C
  81. C --- DO WHILE NUMBER OF CHARACTERS IN WORK < NUMBER OF CHARACTERS IN STRING
  82. C
  83. 100   IS = IS + 1
  84.       IF (STRING(IS:IS) .EQ. '<') THEN
  85.          IT = IS + 4
  86.          IF ((IT .LE. L) .AND. (STRING(IT:IT) .EQ. '>')) THEN
  87. C
  88. C ------    IT APPEARS TO BE AN ASCII REPRESENTATION
  89. C
  90.             IS = IS + 1
  91.             IT = IT - 1
  92.             THREE = STRING(IS:IT)
  93. C
  94. C ------    SEE IF THE TEXT STRING IS AN ASCII CHARACTER MNEMONIC
  95. C
  96.             DO 110 I = 0,32
  97.                IF (THREE .EQ. TABLE(I)) THEN
  98.                   IW = IW + 1
  99.                   IF (IW .GT. 255) GO TO 1000
  100.                   IF (I .EQ. 32) THEN
  101.                      WORK(IW:IW) = CHAR(127)
  102.                   ELSE
  103.                      WORK(IW:IW) = CHAR(I)
  104.                   ENDIF
  105.                   IS = IS + 3
  106.                   IF (IS .LT. L) GO TO 100
  107.                   GO TO 1000
  108.                ENDIF
  109. 110            CONTINUE
  110. C
  111. C ------    NOT IN TABLE, SEE IF NUMERIC
  112. C
  113.             DO 120 I = 1,3
  114.                IF((THREE(I:I) .LT. '0') .OR. (THREE(I:I) .GT. '9'))THEN
  115.                   IW = IW + 1
  116.                   IF (IW .GT. 255) GO TO 1000
  117.                   WORK(IW:IW) = '<'
  118.                   GO TO 200
  119.                ENDIF
  120. 120            CONTINUE
  121. C
  122. C ------    ALL DIGITS
  123. C
  124.             READ ( THREE, 900 )I
  125.             IF ((I .LE. 255) .AND. (I .GE. 128)) THEN
  126. C
  127. C ------    OK, ITS NUMERIC
  128. C
  129.                IS = IS + 3
  130.                IW = IW + 1
  131.                IF (IW .GT. 255) GO TO 1000
  132.                WORK(IW:IW) = CHAR(I)
  133.                IF (IS .LT. L) GO TO 100
  134.                GO TO 1000
  135.             ELSE
  136. C
  137. C -----   NOT NUMERIC, MUST BE COINCIDENCE
  138. C
  139.                IW = IW + 1
  140.                IF (IW .GT. 255) GO TO 1000
  141.                WORK(IW:IW) = '<'
  142.             ENDIF
  143.          ENDIF
  144.       ENDIF
  145. 200   IW = IW + 1
  146.       IF (IW .GT. 255) GO TO 1000
  147.       WORK(IW:IW) = STRING(IS:IS)
  148.       IF ( IS .LT. L ) GO TO 100
  149. C
  150. C --- END DO WHILE
  151. C
  152. C --- OUTPUT STRING FULL OR INPUT STRING DEPLETED
  153. C
  154. 1000  STRING = WORK
  155.       RETURN
  156. 900   FORMAT (I3)
  157.       END
  158. C
  159. C---END ASCII
  160. C
  161.